home *** CD-ROM | disk | FTP | other *** search
/ Windows Game Programming for Dummies (2nd Edition) / WinGamProgFD.iso / pc / DirectX SDK / DXSDK / samples / Multimedia / VBSamples / DirectPlay / SimpleServer / frmServer.frm (.txt) next >
Encoding:
Visual Basic Form  |  2001-10-08  |  14.6 KB  |  367 lines
  1. VERSION 5.00
  2. Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
  3. Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
  4. Begin VB.Form frmServer 
  5.    BorderStyle     =   3  'Fixed Dialog
  6.    Caption         =   "DirectPlay Simple Server"
  7.    ClientHeight    =   4875
  8.    ClientLeft      =   45
  9.    ClientTop       =   330
  10.    ClientWidth     =   3660
  11.    Icon            =   "frmServer.frx":0000
  12.    LinkTopic       =   "Form1"
  13.    MaxButton       =   0   'False
  14.    MinButton       =   0   'False
  15.    ScaleHeight     =   4875
  16.    ScaleWidth      =   3660
  17.    StartUpPosition =   3  'Windows Default
  18.    Begin VB.CommandButton cmdStartServer 
  19.       Caption         =   "Start Server"
  20.       Default         =   -1  'True
  21.       Height          =   375
  22.       Left            =   1283
  23.       TabIndex        =   9
  24.       Top             =   4080
  25.       Width           =   1095
  26.    End
  27.    Begin VB.ListBox lstUser 
  28.       Height          =   1815
  29.       Left            =   120
  30.       TabIndex        =   8
  31.       Top             =   2160
  32.       Width           =   3375
  33.    End
  34.    Begin MSComctlLib.StatusBar sBar 
  35.       Align           =   2  'Align Bottom
  36.       Height          =   375
  37.       Left            =   0
  38.       TabIndex        =   7
  39.       Top             =   4500
  40.       Width           =   3660
  41.       _ExtentX        =   6456
  42.       _ExtentY        =   661
  43.       Style           =   1
  44.       _Version        =   393216
  45.       BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
  46.          NumPanels       =   1
  47.          BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
  48.          EndProperty
  49.       EndProperty
  50.    End
  51.    Begin MSComCtl2.UpDown udUsers 
  52.       Height          =   315
  53.       Left            =   3180
  54.       TabIndex        =   5
  55.       Top             =   1740
  56.       Width           =   240
  57.       _ExtentX        =   423
  58.       _ExtentY        =   556
  59.       _Version        =   393216
  60.       Value           =   50
  61.       BuddyControl    =   "txtUsers"
  62.       BuddyDispid     =   196611
  63.       OrigLeft        =   1800
  64.       OrigTop         =   660
  65.       OrigRight       =   2040
  66.       OrigBottom      =   975
  67.       Max             =   1000
  68.       Min             =   1
  69.       SyncBuddy       =   -1  'True
  70.       BuddyProperty   =   65547
  71.       Enabled         =   -1  'True
  72.    End
  73.    Begin VB.TextBox txtUsers 
  74.       Height          =   315
  75.       Left            =   2760
  76.       Locked          =   -1  'True
  77.       TabIndex        =   4
  78.       Text            =   "50"
  79.       Top             =   1740
  80.       Width           =   435
  81.    End
  82.    Begin VB.TextBox txtSession 
  83.       Height          =   315
  84.       Left            =   120
  85.       TabIndex        =   3
  86.       Text            =   "vbDirectPlaySession"
  87.       Top             =   1320
  88.       Width           =   3315
  89.    End
  90.    Begin VB.ListBox lstSP 
  91.       Height          =   645
  92.       Left            =   120
  93.       TabIndex        =   1
  94.       Top             =   420
  95.       Width           =   3375
  96.    End
  97.    Begin VB.Label lbl 
  98.       BackStyle       =   0  'Transparent
  99.       Caption         =   "Select the server's service provider"
  100.       Height          =   195
  101.       Index           =   2
  102.       Left            =   120
  103.       TabIndex        =   6
  104.       Top             =   120
  105.       Width           =   3435
  106.    End
  107.    Begin VB.Label lbl 
  108.       BackStyle       =   0  'Transparent
  109.       Caption         =   "Session Name"
  110.       Height          =   195
  111.       Index           =   1
  112.       Left            =   120
  113.       TabIndex        =   2
  114.       Top             =   1080
  115.       Width           =   1275
  116.    End
  117.    Begin VB.Label lbl 
  118.       BackStyle       =   0  'Transparent
  119.       Caption         =   "Maximum users:"
  120.       Height          =   255
  121.       Index           =   0
  122.       Left            =   240
  123.       TabIndex        =   0
  124.       Top             =   1800
  125.       Width           =   2415
  126.    End
  127.    Begin VB.Menu mnuPop 
  128.       Caption         =   "PopUp"
  129.       Visible         =   0   'False
  130.       Begin VB.Menu mnuShow 
  131.          Caption         =   "Show"
  132.       End
  133.       Begin VB.Menu mnuStart 
  134.          Caption         =   "Start Server"
  135.       End
  136.       Begin VB.Menu mnuSep 
  137.          Caption         =   "-"
  138.       End
  139.       Begin VB.Menu mnuExit 
  140.          Caption         =   "Exit"
  141.       End
  142.    End
  143. Attribute VB_Name = "frmServer"
  144. Attribute VB_GlobalNameSpace = False
  145. Attribute VB_Creatable = False
  146. Attribute VB_PredeclaredId = True
  147. Attribute VB_Exposed = False
  148. Option Explicit
  149. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  150. '  Copyright (C) 1999-2001 Microsoft Corporation.  All Rights Reserved.
  151. '  File:       frmServer.frm
  152. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  153. Implements DirectPlay8Event
  154. Private mfExit As Boolean
  155. Private Enum MsgTypes
  156.     Msg_NoOtherPlayers
  157.     Msg_NumPlayers
  158.     Msg_SendWave
  159. End Enum
  160. Private Sub cmdStartServer_Click()
  161.     Dim AppDesc As DPN_APPLICATION_DESC
  162.     If gfStarted Then Exit Sub
  163.     If Val(txtUsers.Text) < 1 Then
  164.         MsgBox "I'm sorry, you must allow at least 1 user to join your server.", vbOKOnly Or vbInformation, "Increase users"
  165.         Exit Sub
  166.     End If
  167.     If txtSession.Text = vbNullString Then
  168.         MsgBox "I'm sorry, you must enter a session name.", vbOKOnly Or vbInformation, "No session name"
  169.         Exit Sub
  170.     End If
  171.     'Save our current session name for later runs
  172.     SaveSetting "VBDirectPlay", "Defaults", "ServerGameName", txtSession.Text
  173.     'Now set up the app description
  174.     With AppDesc
  175.         .guidApplication = AppGuid
  176.         .lMaxPlayers = Val(txtUsers.Text)
  177.         .SessionName = txtSession.Text
  178.         .lFlags = DPNSESSION_CLIENT_SERVER 'We must pass the client server flags if we are a server
  179.     End With
  180.     'Now set up our address value
  181.     dpa.SetSP dps.GetServiceProvider(lstSP.ListIndex + 1).Guid
  182.     'Now start the server
  183.     dps.Host AppDesc, dpa
  184.     gfStarted = True
  185.     sBar.SimpleText = "Server running...  (" & CStr(glNumPlayers) & "/" & txtUsers.Text & " clients connected.)"
  186.     'modify our icon text
  187.     sysIcon.sTip = "Server running...  (" & CStr(glNumPlayers) & "/" & txtUsers.Text & " clients connected.)" & vbNullChar
  188.     sysIcon.uFlags = NIF_TIP
  189.     Shell_NotifyIcon NIM_MODIFY, sysIcon
  190.     cmdStartServer.Enabled = False
  191. End Sub
  192. Private Sub Form_Load()
  193.     Dim lCount As Long
  194.     Dim dpn As DPN_SERVICE_PROVIDER_INFO
  195.     dps.RegisterMessageHandler Me
  196.     'First load our list of Service Providers into our box
  197.     For lCount = 1 To dps.GetCountServiceProviders
  198.         dpn = dps.GetServiceProvider(lCount)
  199.         lstSP.AddItem dpn.Name
  200.         'Pick the TCP/IP connection by default
  201.         If InStr(dpn.Name, "TCP") Then lstSP.ListIndex = lstSP.ListCount - 1
  202.     Next
  203.     If lstSP.ListIndex < 0 Then lstSP.ListIndex = 0
  204.     txtSession.Text = GetSetting("VBDirectPlay", "Defaults", "ServerGameName", "vbDirectPlayServer")
  205.     sBar.SimpleText = "Server not running..."
  206.     'Lets put an icon in the system tray
  207.     With sysIcon
  208.         .cbSize = LenB(sysIcon)
  209.         .hwnd = Me.hwnd
  210.         .uFlags = NIF_DOALL
  211.         .uCallbackMessage = WM_MOUSEMOVE
  212.         .hIcon = Me.Icon
  213.         .sTip = "vbDirectPlayServer - Server not running" & vbNullChar
  214.     End With
  215.     Shell_NotifyIcon NIM_ADD, sysIcon
  216. End Sub
  217. Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  218.     Dim ShellMsg As Long
  219.     ShellMsg = X / Screen.TwipsPerPixelX
  220.     Select Case ShellMsg
  221.     Case WM_LBUTTONDBLCLK
  222.         mnuShow_Click
  223.     Case WM_RBUTTONUP
  224.         'Show the menu
  225.         If gfStarted Then mnuStart.Enabled = False
  226.         PopupMenu mnuPop, , , , mnuShow
  227.     End Select
  228. End Sub
  229. Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  230.     If Not mfExit Then
  231.         Cancel = 1
  232.         Me.Hide
  233.     End If
  234. End Sub
  235. Private Sub Form_Unload(Cancel As Integer)
  236.     Shell_NotifyIcon NIM_DELETE, sysIcon
  237.     Cleanup
  238. End Sub
  239. Private Sub mnuExit_Click()
  240.     mfExit = True
  241.     Unload Me
  242. End Sub
  243. Private Sub mnuShow_Click()
  244.     Me.Visible = True
  245.     Me.SetFocus
  246. End Sub
  247. Private Sub mnuStart_Click()
  248.     cmdStartServer_Click
  249. End Sub
  250. Private Sub udUsers_Change()
  251.     Dim AppDesc As DPN_APPLICATION_DESC
  252.     If gfStarted Then
  253.         'We need to reset our max users
  254.         AppDesc = dps.GetApplicationDesc(0)
  255.         AppDesc.lMaxPlayers = udUsers.Value
  256.         dps.SetApplicationDesc AppDesc, 0
  257.         sBar.SimpleText = "Server running...  (" & CStr(glNumPlayers) & "/" & txtUsers.Text & " clients connected.)"
  258.         
  259.         'modify our icon text
  260.         sysIcon.sTip = "Server running...  (" & CStr(glNumPlayers) & "/" & txtUsers.Text & " clients connected.)" & vbNullChar
  261.         sysIcon.uFlags = NIF_TIP
  262.         Shell_NotifyIcon NIM_MODIFY, sysIcon
  263.         NotifyEveryoneOfNumPlayers
  264.     End If
  265. End Sub
  266. Private Sub NotifyEveryoneOfNumPlayers()
  267.     Dim oBuf() As Byte
  268.     Dim lMsg As Long, lOffset As Long
  269.     'Here we will notify everyone currently in the session about the number of players in the session
  270.     lOffset = NewBuffer(oBuf)
  271.     lMsg = Msg_NumPlayers
  272.     AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
  273.     AddDataToBuffer oBuf, glNumPlayers, LenB(glNumPlayers), lOffset
  274.     AddDataToBuffer oBuf, CLng(udUsers.Value), SIZE_LONG, lOffset
  275.     dps.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK
  276. End Sub
  277. Private Sub DirectPlay8Event_AddRemovePlayerGroup(ByVal lMsgID As Long, ByVal lPlayerID As Long, ByVal lGroupID As Long, fRejectMsg As Boolean)
  278.     'VB requires that we must implement *every* member of this interface
  279. End Sub
  280. Private Sub DirectPlay8Event_AppDesc(fRejectMsg As Boolean)
  281.     'VB requires that we must implement *every* member of this interface
  282. End Sub
  283. Private Sub DirectPlay8Event_AsyncOpComplete(dpnotify As DxVBLibA.DPNMSG_ASYNC_OP_COMPLETE, fRejectMsg As Boolean)
  284.     'VB requires that we must implement *every* member of this interface
  285. End Sub
  286. Private Sub DirectPlay8Event_ConnectComplete(dpnotify As DxVBLibA.DPNMSG_CONNECT_COMPLETE, fRejectMsg As Boolean)
  287.     'VB requires that we must implement *every* member of this interface
  288. End Sub
  289. Private Sub DirectPlay8Event_CreateGroup(ByVal lGroupID As Long, ByVal lOwnerID As Long, fRejectMsg As Boolean)
  290.     'VB requires that we must implement *every* member of this interface
  291. End Sub
  292. Private Sub DirectPlay8Event_CreatePlayer(ByVal lPlayerID As Long, fRejectMsg As Boolean)
  293.     On Error Resume Next
  294.     Dim dpPeer As DPN_PLAYER_INFO
  295.     dpPeer = dps.GetClientInfo(lPlayerID)
  296.     If Err Then Exit Sub
  297.     glNumPlayers = glNumPlayers + 1
  298.     sBar.SimpleText = "Server running...  (" & CStr(glNumPlayers) & "/" & txtUsers.Text & " clients connected.)"
  299.     sysIcon.sTip = "Server running...  (" & CStr(glNumPlayers) & "/" & txtUsers.Text & " clients connected.)" & vbNullChar
  300.     sysIcon.uFlags = NIF_TIP
  301.     Shell_NotifyIcon NIM_MODIFY, sysIcon
  302.     'Add this player to the list
  303.     lstUser.AddItem dpPeer.Name & " DPlay ID: 0x" & Hex$(lPlayerID)
  304.     lstUser.ItemData(lstUser.ListCount - 1) = lPlayerID
  305.     NotifyEveryoneOfNumPlayers
  306. End Sub
  307. Private Sub DirectPlay8Event_DestroyGroup(ByVal lGroupID As Long, ByVal lReason As Long, fRejectMsg As Boolean)
  308.     'VB requires that we must implement *every* member of this interface
  309. End Sub
  310. Private Sub DirectPlay8Event_DestroyPlayer(ByVal lPlayerID As Long, ByVal lReason As Long, fRejectMsg As Boolean)
  311.     Dim lCount As Long
  312.     For lCount = lstUser.ListCount - 1 To 0 Step -1
  313.         If lstUser.ItemData(lCount) = lPlayerID Then 'remove this player from the list
  314.             lstUser.RemoveItem lCount
  315.         End If
  316.     Next
  317.     glNumPlayers = glNumPlayers - 1
  318.     sBar.SimpleText = "Server running...  (" & CStr(glNumPlayers) & "/" & txtUsers.Text & " clients connected.)"
  319.     sysIcon.sTip = "Server running...  (" & CStr(glNumPlayers) & "/" & txtUsers.Text & " clients connected.)" & vbNullChar
  320.     sysIcon.uFlags = NIF_TIP
  321.     Shell_NotifyIcon NIM_MODIFY, sysIcon
  322.     NotifyEveryoneOfNumPlayers
  323. End Sub
  324. Private Sub DirectPlay8Event_EnumHostsQuery(dpnotify As DxVBLibA.DPNMSG_ENUM_HOSTS_QUERY, fRejectMsg As Boolean)
  325.     'VB requires that we must implement *every* member of this interface
  326. End Sub
  327. Private Sub DirectPlay8Event_EnumHostsResponse(dpnotify As DxVBLibA.DPNMSG_ENUM_HOSTS_RESPONSE, fRejectMsg As Boolean)
  328.     'VB requires that we must implement *every* member of this interface
  329. End Sub
  330. Private Sub DirectPlay8Event_HostMigrate(ByVal lNewHostID As Long, fRejectMsg As Boolean)
  331.     'VB requires that we must implement *every* member of this interface
  332. End Sub
  333. Private Sub DirectPlay8Event_IndicateConnect(dpnotify As DxVBLibA.DPNMSG_INDICATE_CONNECT, fRejectMsg As Boolean)
  334.     'VB requires that we must implement *every* member of this interface
  335. End Sub
  336. Private Sub DirectPlay8Event_IndicatedConnectAborted(fRejectMsg As Boolean)
  337.     'VB requires that we must implement *every* member of this interface
  338. End Sub
  339. Private Sub DirectPlay8Event_InfoNotify(ByVal lMsgID As Long, ByVal lNotifyID As Long, fRejectMsg As Boolean)
  340.     'VB requires that we must implement *every* member of this interface
  341. End Sub
  342. Private Sub DirectPlay8Event_Receive(dpnotify As DxVBLibA.DPNMSG_RECEIVE, fRejectMsg As Boolean)
  343.     Dim oNewMsg() As Byte, lOffset As Long
  344.     Dim lMsg As Long
  345.     'The only message we will receive from our client is one to make faces to everyone
  346.     'else on the server, if there is someone else to make faces at, do it, otherwise let
  347.     'them know
  348.     If glNumPlayers > 1 Then
  349.         lOffset = NewBuffer(oNewMsg)
  350.         lMsg = Msg_SendWave
  351.         AddDataToBuffer oNewMsg, lMsg, LenB(lMsg), lOffset
  352.         AddStringToBuffer oNewMsg, dps.GetClientInfo(dpnotify.idSender).Name, lOffset
  353.         dps.SendTo DPNID_ALL_PLAYERS_GROUP, oNewMsg, 0, DPNSEND_NOLOOPBACK
  354.     Else
  355.         lOffset = NewBuffer(oNewMsg)
  356.         lMsg = Msg_NoOtherPlayers
  357.         AddDataToBuffer oNewMsg, lMsg, LenB(lMsg), lOffset
  358.         dps.SendTo DPNID_ALL_PLAYERS_GROUP, oNewMsg, 0, DPNSEND_NOLOOPBACK
  359.     End If
  360. End Sub
  361. Private Sub DirectPlay8Event_SendComplete(dpnotify As DxVBLibA.DPNMSG_SEND_COMPLETE, fRejectMsg As Boolean)
  362.     'VB requires that we must implement *every* member of this interface
  363. End Sub
  364. Private Sub DirectPlay8Event_TerminateSession(dpnotify As DxVBLibA.DPNMSG_TERMINATE_SESSION, fRejectMsg As Boolean)
  365.     'VB requires that we must implement *every* member of this interface
  366. End Sub
  367.